home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / qp.scm < prev    next >
Text File  |  1999-04-19  |  5KB  |  150 lines
  1. ;;;; "qp.scm" Print finite length representation for any Scheme object.
  2. ;;; Copyright (C) 1991, 1992, 1993, 1995 Aubrey Jaffer.
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (define *qp-width* (output-port-width (current-output-port)))
  21.  
  22. (define qp:qp
  23.   (let
  24.       ((+ +) (- -) (< <) (= =) (>= >=) (apply apply) (boolean? boolean?)
  25.        (car car) (cdr cdr) (char? char?) (display display) (eq? eq?)
  26.        (for-each for-each) (input-port? input-port?)
  27.        (not not) (null? null?) (number->string number->string)
  28.        (number? number?) (output-port? output-port?) (eof-object? eof-object?)
  29.        (procedure? procedure?) (string-length string-length)
  30.        (string? string?) (substring substring)
  31.        (symbol->string symbol->string) (symbol? symbol?)
  32.        (vector-length vector-length) (vector-ref vector-ref)
  33.        (vector? vector?) (write write) (quotient quotient))
  34.     (letrec
  35.     ((num-cdrs
  36.       (lambda (pairs max-cdrs)
  37.         (cond
  38.          ((null? pairs) 0)
  39.          ((< max-cdrs 1) 1)
  40.          ((pair? pairs) (+ 1 (num-cdrs (cdr pairs) (- max-cdrs 1))))
  41.          (else 1))))
  42.  
  43.      (l-elt-room
  44.       (lambda (room pairs)
  45.         (quotient room (num-cdrs pairs (quotient room 8)))))
  46.  
  47.      (qp-pairs
  48.       (lambda (cdrs room)
  49.         (cond
  50.          ((null? cdrs) 0)
  51.          ((not (pair? cdrs))
  52.           (display " . ")
  53.           (+ 3 (qp-obj cdrs (l-elt-room (- room 3) cdrs))))
  54.          ((< 11 room)
  55.           (display #\ )
  56.           ((lambda (used)
  57.          (+ (qp-pairs (cdr cdrs) (- room used)) used))
  58.            (+ 1 (qp-obj (car cdrs) (l-elt-room (- room 1) cdrs)))))
  59.          (else
  60.           (display " ...") 4))))
  61.  
  62.      (v-elt-room
  63.       (lambda (room vleft)
  64.         (quotient room (min vleft (quotient room 8)))))
  65.  
  66.      (qp-vect
  67.       (lambda (vect i room)
  68.         (cond
  69.          ((= (vector-length vect) i) 0)
  70.          ((< 11 room)
  71.           (display #\ )
  72.           ((lambda (used)
  73.          (+ (qp-vect vect (+ i 1) (- room used)) used))
  74.            (+ 1 (qp-obj (vector-ref vect i)
  75.                 (v-elt-room (- room 1)
  76.                     (- (vector-length vect) i))))))
  77.          (else
  78.           (display " ...") 4))))
  79.  
  80.      (qp-string
  81.       (lambda (str room)
  82.         (cond
  83.          ((>= (string-length str) room 3)
  84.           (display (substring str 0 (- room 3)))
  85.           (display "...")
  86.           room)
  87.          (else
  88.           (display str)
  89.           (string-length str)))))
  90.  
  91.      (qp-obj
  92.       (lambda (obj room)
  93.         (cond
  94.          ((null? obj) (write obj) 2)
  95.          ((boolean? obj) (write obj) 2)
  96.          ((char? obj) (write obj) 8)
  97.          ((number? obj) (qp-string (number->string obj) room))
  98.          ((string? obj)
  99.           (display #\")
  100.           ((lambda (ans) (display #\") ans)
  101.            (+ 2 (qp-string obj (- room 2)))))
  102.          ((symbol? obj) (qp-string (symbol->string obj) room))
  103.          ((input-port? obj) (display "#[input]") 8)
  104.          ((output-port? obj) (display "#[output]") 9)
  105.          ((procedure? obj) (display "#[proc]") 7)
  106.          ((eof-object? obj) (display "#[eof]") 6)
  107.          ((vector? obj)
  108.           (set! room (- room 3))
  109.           (display "#(")
  110.           ((lambda (used) (display #\)) (+ used 3))
  111.            (cond
  112.         ((= 0 (vector-length obj)) 0)
  113.         ((< room 8) (display "...") 3)
  114.         (else
  115.          ((lambda (used) (+ (qp-vect obj 1 (- room used)) used))
  116.           (qp-obj (vector-ref obj 0)
  117.               (v-elt-room room (vector-length obj))))))))
  118.          ((pair? obj)
  119.           (set! room (- room 2))
  120.           (display #\()
  121.           ((lambda (used) (display #\)) (+ 2 used))
  122.            (if (< room 8) (begin (display "...") 3)
  123.            ((lambda (used)
  124.               (+ (qp-pairs (cdr obj) (- room used)) used))
  125.             (qp-obj (car obj) (l-elt-room room obj))))))
  126.          (else (display "#[unknown]") 10)))))
  127.  
  128.       (lambda objs
  129.     (cond
  130.      ((or (not *qp-width*) (= 0 *qp-width*))
  131.       (for-each (lambda (x) (write x) (display #\ )) objs)
  132.       (newline))
  133.      (else
  134.       (qp-pairs (cdr objs)
  135.             (- *qp-width*
  136.                (qp-obj (car objs) (l-elt-room *qp-width* objs))))))))))
  137.  
  138. (define qp:qpn
  139.   (let ((newline newline) (apply apply) (qp:qp qp:qp))
  140.     (lambda objs (apply qp:qp objs) (newline))))
  141.  
  142. (define qp:qpr
  143.   (let ((- -) (apply apply) (length length) (list-ref list-ref) (qp:qpn qp:qpn))
  144.     (lambda objs (apply qp:qpn objs)
  145.         (list-ref objs (- (length objs) 1)))))
  146.  
  147. (define qp qp:qp)
  148. (define qpn qp:qpn)
  149. (define qpr qp:qpr)
  150.